home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
mpfeel.lha
/
MPFeel
/
print.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-10-06
|
17KB
|
652 lines
/* ******************************************************************** */
/* print.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* Output functions */
/* ******************************************************************** */
/*
* Change Log:
* Version 1, April 1989
* Added write function - RJB
* Fixed results of prin and write - JPff
* Added printing of macros - JPff
* some classes - RJB
*/
#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include "defs.h"
#include "structs.h"
#include "funcalls.h"
#include "error.h"
#include "global.h"
#include "vectors.h"
#include "table.h"
#include "bootstrap.h"
#include "modboot.h"
#include "ngenerics.h"
#if (defined(MACHINE_SYSTEMV) || defined(MACHINE_BSD))
static char linebuff[200];
FILE* current_output;
#define LINEBUFF() (linebuff)
#define CURRENT_OUTPUT() (current_output)
#endif
#ifdef MACHINE_ANY
static char linebuff[200];
FILE* current_output;
#define LINEBUFF() (linebuff)
#define CURRENT_OUTPUT() (current_output)
#endif
#ifdef MACHINE_TITAN
static char linebuff[PROCESSORS][200];
FILE* current_output[PROCESSORS];
#define LINEBUFF() (linebuff[THIS_PROCESS])
#define CURRENT_OUTPUT() (current_output[THIS_PROCESS])
#endif
/*
* Reconstructable symbol printer by rjb...
*/
static void print_id(char *id, FILE *stream)
{
extern int escaped_id(char *);
if (escaped_id(id)) {
putc('|', stream);
while (*id) {
if (*id == '\\' || *id == '|') putc('\\', stream);
putc(*id++, stream);
}
putc('|', stream);
}
else {
fputs(id, stream);
}
}
/* do we need to escape this id when printing?
* yes if (1) it contains a dodgy character
* (2) it is the id of zero length
* (3) it starts with the syntax of a number
*
* ASCII dependent
*/
/* Redundant copy---see parser.lex */
#if 0
static int escaped_id(char *id)
{
int i;
for (i = 0; id[i]; i++)
if (id[i] < 32 || id[i] > 126 || id[i] == '|' || id[i] == '\\') return 1;
if (strpbrk(id, "|\\#()\"',;` ") ||
id[0] == 0 || /* zero length id */
isdigit(id[0]) || /* 123 */
(id[0] == '.' && id[1] && isdigit(id[1])) || /* .123 */
((id[0] == '+' || id[0] == '-') &&
id[1] && (isdigit(id[1]) || /* +123 */
(id[1] == '.' && id[2] && isdigit(id[2]))))) /* +.123 */
return 1;
else
return 0;
}
#endif
LispObject Fn_prin_internal(LispObject*);
/*
* Hacked internal writer...
*/
EUFUN_1( Fn_write_internal, form)
{
int i;
LispObject ans = form;
switch (typeof(form)) {
case NULL:
sprintf(LINEBUFF(),"#<collected-object: %x %x>",
form->HUNK.hunk_size,
(int) form);
fputs(LINEBUFF(),CURRENT_OUTPUT());
break;
case TYPE_NULL:
fputs("()",CURRENT_OUTPUT());
break;
case TYPE_INT:
sprintf(LINEBUFF(),"%d",intval(form));
fputs(LINEBUFF(),CURRENT_OUTPUT());
break;
case TYPE_FLOAT:
{
sprintf(LINEBUFF(),"%lf",form->FLOAT.fvalue);
fputs(LINEBUFF(),CURRENT_OUTPUT());
}
break;
case TYPE_COMPLEX:
fputs("#C(",CURRENT_OUTPUT());
EUCALL_1(Fn_write_internal,(form->COMPLEX).real);
putc(',',CURRENT_OUTPUT());
form = ARG_0(stackbase);
EUCALL_1(Fn_write_internal,(form->COMPLEX).imaginary);
putc(')',CURRENT_OUTPUT());
break;
case TYPE_CHAR:
if (form == q_eof) {
fprintf(CURRENT_OUTPUT(),"<<EOS>>");
break;
}
putc('#', CURRENT_OUTPUT());
putc('\\', CURRENT_OUTPUT());
switch ((form->CHAR).code) {
case ' ':
fputs("space", CURRENT_OUTPUT());
break;
case '\n':
fputs("newline", CURRENT_OUTPUT());
break;
case '\r':
fputs("return", CURRENT_OUTPUT());
break;
case '\t':
fputs("tab", CURRENT_OUTPUT());
break;
default:
if (!isprint((form->CHAR).code)) {
sprintf(LINEBUFF(), "%03o", (form->CHAR).code);
fputs(LINEBUFF(),CURRENT_OUTPUT());
}
else putc((form->CHAR).code,CURRENT_OUTPUT());
break;
}
break;
case TYPE_SYMBOL:
if (form == nil)
fprintf(CURRENT_OUTPUT(),"()");
else
print_id(form->SYMBOL.pname,CURRENT_OUTPUT());
break;
case TYPE_STRING:
putc('"',CURRENT_OUTPUT());
sprintf(LINEBUFF(),"%s",stringof(form));
for (i = 0; LINEBUFF()[i] != 0; i++) {
switch (LINEBUFF()[i]) {
case '\n':
putc('\\', CURRENT_OUTPUT());
putc('n', CURRENT_OUTPUT());
break;
case '\r':
putc('\\', CURRENT_OUTPUT());
putc('r', CURRENT_OUTPUT());
break;
case '\t':
putc('\\', CURRENT_OUTPUT());
putc('t', CURRENT_OUTPUT());
break;
case '\f':
putc('\\', CURRENT_OUTPUT());
putc('p', CURRENT_OUTPUT());
case '"':
putc('\\', CURRENT_OUTPUT());
putc('"', CURRENT_OUTPUT());
break;
case '\\':
putc('\\', CURRENT_OUTPUT());
putc('\\', CURRENT_OUTPUT());
break;
default:
putc(LINEBUFF()[i], CURRENT_OUTPUT());
break;
}
}
putc('"',CURRENT_OUTPUT());
break;
case TYPE_CONS:
putc('(',CURRENT_OUTPUT());
EUCALL_1(Fn_write_internal, CAR(form));
form = ARG_0(stackbase);
while (is_cons(CDR(form))) {
putc(' ',CURRENT_OUTPUT());
form = CDR(form);
ARG_0(stackbase) = form;
EUCALL_1(Fn_write_internal,CAR(form));
form = ARG_0(stackbase);
}
if (CDR(form) == nil) putc(')',CURRENT_OUTPUT());
else {
putc(' ',CURRENT_OUTPUT());
putc('.',CURRENT_OUTPUT());
putc(' ',CURRENT_OUTPUT());
EUCALL_1(Fn_write_internal, CDR(form));
putc(')',CURRENT_OUTPUT());
}
break;
case TYPE_I_FUNCTION:
{
LispObject body;
/*
Env env;
*/
fputs("#<interpreted-function: (lambda ",CURRENT_OUTPUT());
EUCALL_1(Fn_prin_internal, (form->I_FUNCTION).bvl);
form = ARG_0(stackbase);
body = form->I_FUNCTION.body;
while ( body != nil ) {
fprintf(CURRENT_OUTPUT()," ");
STACK_TMP(CDR(body));
EUCALL_1(Fn_prin_internal, CAR(body));
UNSTACK_TMP(body);
}
putc(')',CURRENT_OUTPUT());
#if 0
for (env = form->I_FUNCTION.env; env != NULL; env = env->next) {
fprintf(CURRENT_OUTPUT()," %s=",env->variable->SYMBOL.pname);
EUCALL_1(Fn_prin_internal,env->value);
}
#endif
fprintf(CURRENT_OUTPUT()," @ %s>",
form->I_FUNCTION.home->I_MODULE.name->SYMBOL.pname);
}
break;
default:
{
EUCALL_1(Fn_prin_internal, form);
}
}
return ans;
}
EUFUN_CLOSE
EUFUN_2( Fn_write, form, stream)
{
if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
else CURRENT_OUTPUT() = (stream->STREAM).handle;
return Fn_write_internal(stackbase);
}
EUFUN_CLOSE
EUFUN_1( Fn_prin_internal, form)
{
LispObject ans = form;
if (form==NULL) {
fprintf(CURRENT_OUTPUT(),"<<NULL>>");
return ans;
}
STACK_TMP(ans);
switch (typeof(form)) {
case NULL:
sprintf(LINEBUFF(),"#<collected-object: %x %x>",
form->HUNK.hunk_size,
(int) form);
fputs(LINEBUFF(),CURRENT_OUTPUT());
break;
case TYPE_NULL:
fprintf(CURRENT_OUTPUT(),"()");
break;
case TYPE_WEAK_WRAPPER:
fprintf(CURRENT_OUTPUT(),"#<weak-wrapper: ");
EUCALL_1(Fn_prin_internal,form->WEAK_WRAPPER.object);
fprintf(CURRENT_OUTPUT(),">");
break;
case TYPE_INT:
sprintf(LINEBUFF(),"%d",intval(form));
fputs(LINEBUFF(),CURRENT_OUTPUT());
break;
case TYPE_RATIONAL:
EUCALL_1(Fn_prin_internal,form->RATIO.numerator);
fprintf(CURRENT_OUTPUT(),"/");
form = ARG_0(stackbase);
EUCALL_1(Fn_prin_internal,form->RATIO.denominator);
break;
case TYPE_FLOAT:
{
sprintf(LINEBUFF(),"%lf",form->FLOAT.fvalue);
fputs(LINEBUFF(),CURRENT_OUTPUT());
}
break;
case TYPE_COMPLEX:
fputs("#C(",CURRENT_OUTPUT());
EUCALL_1(Fn_prin_internal,(form->COMPLEX).real);
putc(',',CURRENT_OUTPUT());
form = ARG_0(stackbase);
EUCALL_1(Fn_prin_internal,(form->COMPLEX).imaginary);
putc(')',CURRENT_OUTPUT());
break;
case TYPE_CHAR:
if (form == q_eof)
fprintf(CURRENT_OUTPUT(),"<<EOS>>");
else
putc((form->CHAR).code,CURRENT_OUTPUT());
break;
case TYPE_SYMBOL:
if (form == nil) {
fprintf(CURRENT_OUTPUT(),"()");
}
else {
fprintf(current_output,"%s",(form->SYMBOL.pname));
}
break;
case TYPE_STRING:
sprintf(LINEBUFF(),"%s",stringof(form));
fputs(LINEBUFF(),CURRENT_OUTPUT());
break;
case TYPE_CONS:
putc('(',CURRENT_OUTPUT());
EUCALL_1(Fn_prin_internal, CAR(form));
form = ARG_0(stackbase);
while (is_cons(CDR(form))) {
putc(' ',CURRENT_OUTPUT());
ARG_0(stackbase) = form = CDR(form);
EUCALL_1(Fn_prin_internal, CAR(form));
form = ARG_0(stackbase);
}
if (CDR(form) == nil) putc(')',CURRENT_OUTPUT());
else {
putc(' ',CURRENT_OUTPUT());
putc('.',CURRENT_OUTPUT());
putc(' ',CURRENT_OUTPUT());
EUCALL_1(Fn_prin_internal, CDR(form));
putc(')',CURRENT_OUTPUT());
}
break;
case TYPE_STREAM:
fprintf(CURRENT_OUTPUT(),"#<stream: %d '%c'>",
(int) (form->STREAM.handle),
(char) (form->STREAM.mode));
break;
case TYPE_VECTOR:
fputs("#(",CURRENT_OUTPUT());
{
int i;
for (i=0;i< form->VECTOR.length-1;++i) {
EUCALL_1(Fn_prin_internal,vref(form,i));
form = ARG_0(stackbase);
fputs(" ",CURRENT_OUTPUT());
}
if (form->VECTOR.length > 0)
EUCALL_1(Fn_prin_internal,vref(form,i));
}
fputs(")",CURRENT_OUTPUT());
break;
case TYPE_TABLE:
fputs("#T(",CURRENT_OUTPUT());
if ((form->TABLE).comparator == Fn_equal) fputs("equal",CURRENT_OUTPUT());
else fputs("???",CURRENT_OUTPUT());
putc(')',CURRENT_OUTPUT());
break;
case TYPE_I_FUNCTION:
{
LispObject body;
Env env;
fputs("#<interpreted-function: (lambda ",CURRENT_OUTPUT());
EUCALL_1(Fn_prin_internal,(form->I_FUNCTION).bvl);
form = ARG_0(stackbase);
body = form->I_FUNCTION.body;
while ( body != nil ) {
fprintf(CURRENT_OUTPUT()," ");
STACK_TMP(CDR(body));
EUCALL_1(Fn_prin_internal,CAR(body));
UNSTACK_TMP(body);
}
putc(')',CURRENT_OUTPUT());
form = ARG_0(stackbase);
for (env = form->I_FUNCTION.env; env != NULL; env = env->next) {
fprintf(CURRENT_OUTPUT()," %s=",env->variable->SYMBOL.pname);
STACK_TMPV(env);
EUCALL_1(Fn_prin_internal, env->value);
UNSTACK_TMPV(env);
}
form = ARG_0(stackbase);
fprintf(CURRENT_OUTPUT()," @ %s>",
form->I_FUNCTION.home->I_MODULE.name->SYMBOL.pname);
}
break;
case TYPE_C_FUNCTION:
fprintf(CURRENT_OUTPUT(),"#<c-function: %x %d ",
(int) (form->C_FUNCTION.func),
form->C_FUNCTION.argtype);
if (form->C_FUNCTION.name != nil)
fprintf(CURRENT_OUTPUT(),"%s ",form->C_FUNCTION.name->SYMBOL.pname);
fprintf(CURRENT_OUTPUT(),"@ %s>",
form->C_FUNCTION.home->C_MODULE.name->SYMBOL.pname);
break;
case TYPE_C_MACRO:
fprintf(CURRENT_OUTPUT(),"#<c-macro: %x %d ",
(int) (form->C_FUNCTION.func),
form->C_FUNCTION.argtype);
if (form->C_FUNCTION.name != nil)
fprintf(CURRENT_OUTPUT(),"%s ",form->C_FUNCTION.name->SYMBOL.pname);
fprintf(CURRENT_OUTPUT(),"@ %s>",
form->C_FUNCTION.home->C_MODULE.name->SYMBOL.pname);
break;
case TYPE_I_MACRO:
fputs("#<interpreted-macro:(",CURRENT_OUTPUT());
EUCALL_1(Fn_prin_internal,(form->I_FUNCTION).bvl);
form = ARG_0(stackbase);
EUCALL_1(Fn_prin_internal,(form->I_FUNCTION).body);
putc(')',CURRENT_OUTPUT());
break;
case TYPE_SPECIAL:
fprintf(CURRENT_OUTPUT(),"#<special-form: %x '%s'>",
(int) ((form->SPECIAL).func),
(form->SPECIAL).name->SYMBOL.pname);
break;
#ifdef obsolete /* Tue Jul 30 13:20:19 1991 */
/**/ case TYPE_GENERIC:
/**/ fprintf(CURRENT_OUTPUT(),"#<%s: %d",
/**/ classof(form)->CLASS.name->SYMBOL.pname,
/**/ intval(generic_argtype(form)));
/**/ if (generic_name(form) != nil) {
/**/ fprintf(CURRENT_OUTPUT()," ");
/**/ (void) Fn_prin_internal(generic_name(form));
/**/ }
/**/
/**/ fprintf(CURRENT_OUTPUT()," @ %s>",
/**/ generic_home(form)->C_MODULE.name->SYMBOL.pname);
/**/ break;
/**/ case TYPE_METHOD:
/**/ fprintf(CURRENT_OUTPUT(),"#<%s: ",
/**/ classof(form)->CLASS.name->SYMBOL.pname);
/**/ Fn_prin_internal(/*+::+*//*+:NULL:+*/method_signature(form));
/**/ fprintf(CURRENT_OUTPUT()," ");
/**/ Fn_prin_internal(/*+::+*//*+:NULL:+*/method_host(form));
/**/
/**/ fprintf(CURRENT_OUTPUT(),">");
/**/ break;
#endif /* obsolete Tue Jul 30 13:20:19 1991 */
case TYPE_CONTINUE:
fprintf(CURRENT_OUTPUT(), "#<continuation: %x %s>", (int) form,
(form->CONTINUE).live ? "live" : "dead");
break;
case TYPE_C_MODULE:
fprintf(CURRENT_OUTPUT(), "#<c-module: ");
EUCALL_1(Fn_prin_internal,(form->C_MODULE.name));
putc(' ',CURRENT_OUTPUT());
form = ARG_0(stackbase);
{
LispObject xx;
xx= form->C_MODULE.exported_names;
EUCALL_1(Fn_prin_internal,xx);
}
fprintf(CURRENT_OUTPUT(),">");
break;
case TYPE_I_MODULE:
fprintf(CURRENT_OUTPUT(), "#<interpreted-module: ");
EUCALL_1(Fn_prin_internal,form->I_MODULE.name);
putc(' ',CURRENT_OUTPUT());
form = ARG_0(stackbase);
EUCALL_1(Fn_prin_internal,form->I_MODULE.exported_names);
fprintf(CURRENT_OUTPUT(),">");
break;
case TYPE_ENV:
{
Env runner = (Env) form;
int i = 0;
fputs("#<env: ",CURRENT_OUTPUT());
while (runner!=NULL) {
putc('(',CURRENT_OUTPUT());
STACK_TMPV(runner);
EUCALL_1(Fn_prin_internal,runner->variable);
putc(' ',CURRENT_OUTPUT());
runner = (Env) *(stacktop-1);
EUCALL_1(Fn_prin_internal,runner->value);
putc(')',CURRENT_OUTPUT());
UNSTACK_TMPV(runner);
runner = runner->next;
++i;
}
putc('>',CURRENT_OUTPUT());
}
break;
case TYPE_THREAD:
fprintf(CURRENT_OUTPUT(),"#<thread: %x %d ",
(int) form,form->THREAD.status);
EUCALL_1(Fn_prin_internal,form->THREAD.value);
fprintf(CURRENT_OUTPUT(),">");
break;
case TYPE_SEMAPHORE:
fprintf(CURRENT_OUTPUT(),
"#<semaphore: %x,%x>",(int) form,form->SEMAPHORE.semaphore);
break;
#if (defined(WITH_BSD_SOCKETS) || defined(WITH_SYSTEMV_SOCKETS))
case TYPE_LISTENER:
fprintf(CURRENT_OUTPUT(),"#<listener: %d %d>",
form->LISTENER.socket,
form->LISTENER.state);
break;
case TYPE_SOCKET:
fprintf(CURRENT_OUTPUT(),"#<socket: %d %d>",
form->SOCKET.socket,
form->SOCKET.state);
break;
#endif
default:
if (classp(form) || typeof(form) == TYPE_CLASS ) {
fprintf(CURRENT_OUTPUT(),"#<%s: %s>",
CLASS_NAME(classof(form))->SYMBOL.pname,
CLASS_NAME(form)->SYMBOL.pname);
}
else
fprintf(CURRENT_OUTPUT(), "#<%s: %x>",
CLASS_NAME(classof(form))->SYMBOL.pname,(int) form);
}
UNSTACK_TMP(ans);
return ans;
}
EUFUN_CLOSE
EUFUN_2( Fn_prin, form, stream)
{
if (stream==nil) stream=StdOut;
if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
else CURRENT_OUTPUT() = (stream->STREAM).handle;
EUCALL_1(Fn_prin_internal,form);
CURRENT_OUTPUT() = StdOut->STREAM.handle;
return ARG_0(stackbase);
}
EUFUN_CLOSE
EUFUN_1( Fn_newline, stream)
{
STACK(stream);
if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
else CURRENT_OUTPUT() = (stream->STREAM).handle;
putc('\n',CURRENT_OUTPUT());
CURRENT_OUTPUT() = StdOut->STREAM.handle;
return nil;
}
EUFUN_CLOSE
EUFUN_2( Fn_print, form, stream)
{
if (stream==nil) stream=StdOut;
if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
else CURRENT_OUTPUT() = (stream->STREAM).handle;
EUCALL_1(Fn_prin_internal, form);
putc('\n',CURRENT_OUTPUT());
CURRENT_OUTPUT() = StdOut->STREAM.handle;
return ARG_0(stackbase);
}
EUFUN_CLOSE
EUFUN_2( Fn_writechar, obj, stream)
{
if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
else if (stream==nil) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
else CURRENT_OUTPUT() = (stream->STREAM).handle;
putc((obj->CHAR).code,CURRENT_OUTPUT());
CURRENT_OUTPUT() = StdOut->STREAM.handle;
return obj;
}
EUFUN_CLOSE
EUFUN_2( Fn_writebyte, obj, stream)
{
if (stream==NULL) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
else if (stream==nil) CURRENT_OUTPUT() = (StdOut->STREAM).handle;
else CURRENT_OUTPUT() = (stream->STREAM).handle;
putc(intval(obj),CURRENT_OUTPUT());
CURRENT_OUTPUT() = StdOut->STREAM.handle;
return obj;
}
EUFUN_CLOSE
EUFUN_2( Fn_write_text, str, stream)
{
fprintf(stream->STREAM.handle,"%s",stringof(str));
return(nil);
}
EUFUN_CLOSE
void initialise_output(LispObject *stacktop)
{
(void) make_module_function(stacktop,"write-char", Fn_writechar, 2);
(void) make_module_function(stacktop,"write-byte", Fn_writebyte, 2);
(void) make_module_function(stacktop,"write-text",Fn_write_text,2);
}